perm filename SYNTAX.L70[L70,TES] blob
sn#009940 filedate 1972-06-27 generic text, type T, neo UTF8
00100 LET NEWLET(*,FN,Q,RULES) IDEXP =
00200 {
00300 LET
00400 [IDENTIFIER]
00500 {ALT INCLUDE ONLY | INCLUDE | EXCLUDE | REPLACE }
00600 {REP 0 M * {
00700 {ALT RULES OF [IDENTIFIER] | <RULE> } [FLUSH]
00800 }
00900 {OPT ?,}
01000 }
01100 }
01200 MEAN BEGIN
01300 SPECIAL ?!EXCLUDE, ?!REPLACE, ?!XEXPRS, ?!VARLIST, ?!OPT, ?!OPTVARS,
01400 ?!EVARS, ?!GVARS, ?!SVARS ;
01500 NEW ONLY, ?!EXCLUDE, ?!REPLACE, F, R ;
01600 CASE Q[1] OF BEGIN ONLY←T ; NIL ; PRINTSTR("EXCLUDE not implemented") ; ?!REPLACE←T END ;
01700 F ← FN.XEXPR ;
01800 IF ¬F THEN ?!XEXPRS ← FN CONS ?!XEXPRS ;
01900 IF ONLY THEN FN.XAMBIG ← F ← NIL ;
02000 FOR R IN RULES DO
02100 BEGIN
02200 R ← CASE R[1,1] OF BEGIN R[1,4].XEXPR ; R[1,2] END ;
02300 F ← MERGERULES(R, F) ;
02400 END ;
02500 PRINTSTR("Function " CAT FN CAT CASE Q[1] OF
02600 BEGIN " Redefined" ; " Extended" ; " Shortened" ; " Altered" END ) ;
02700 RETURN <'DEFPROP, FN, F, 'XEXPR> ;
02800 END ;
02900
03000 LET RULESIDE(S) =
03100 {
03200 {REP 1 M * {
03300 <PEXPR> {OPT ?≡ <PEXPR>} {OPT ?{ IF <EXPR> ?} }
03400 } }
03500 }
03600 MEAN FOR NEW X IN S COLLECT
03700 < BEGIN NEW VARNAME, PX ;
03800 IF X[2] THEN BEGIN VARNAME ← X[1] ; PX ← X[2,2] END
03900 ELSE BEGIN VARNAME ← '?& ; PX ← X[1] END ;
04000 RETURN
04100 < VARNAME,
04200 IF ¬X[3] THEN PX
04300 ELSE <'HORSESHOE, <PX, <'CURLIF, X[3,3]>>>
04400 > ;
04500 END
04600 > ;
00100 LET RULE(DECS, ARROWS, RECS) =
00200 {
00300 <RULESIDE>
00400 {REP 1 6 * {
00500 {ALT ?→ | ?← | ?↔ }
00600 } }
00700 <RULESIDE>
00800 }
00900 MEAN BEGIN
01000 NEW ?!VARLIST, DECSIDE, RECSIDE, ?!OPT ;
01100 IF LENGTH(ARROWS) ≠ 1 ∨ ARROWS[1,1,1] ≠ 1 THEN
01200 PRINTSTR("Only DEC→REC is currently implemented!") ;
01300 DECSIDE ← FOR NEW D IN DECS COLLECT
01400 <'TEM_DEC, IF D[1] EQ '?& THEN '?&ARGS ELSE REC(D[1])> CONS DEC(D[2]) ;
01500 RECSIDE ← FOR NEW R IN RECS COLLECT
01600 << 'STORE,
01700 IF R[1] EQ '?& THEN '?&VAL
01800 ELSE IF ATOM R[1] ∨ R[1,1] NEQ 'CURLY ∨ ¬ATOM(R[1,2]) THEN
01900 PRINTSTR("In REC, only $X≡ is allowed") ALSO '?&DUMMY
02000 ELSE R[1,2],
02100 REC(R[2])
02200 >> ;
02300 RETURN( <'LAMBDA, '?&ARGS,
02400 <'PROG,
02500 '?&VAL CONS FOR NEW Y IN ?!VARLIST COLLECT
02600 IF Y[1] ∨ Y[2] EQ 'REC THEN <RULEVAR(Y)> >
02700 @(FOR VV IN ?!VARLIST COLLECT IF VV[2] EQ 'REC THEN
02800 <<'STORE, RULEVAR(VV), <'GENSYM>>>) @
02900 NUMBVARS(DECSIDE) @
03000 <<'TEM_REC, 1>> @
03100 NUMBVARS(RECSIDE) @
03200 <<'RETURN, '?&VAL>>
03300 > ) ;
03400 END ;
03500
03600 BEGIN
03700 ?!EVARS{NIL} ← FOR NEW W IN '(?&E1 ?&E2 ?&E3 ?&E4 ?&E5 ?&E6 ?&E7 ?&E8 ?&E9 ?&E10 ?&E11 ?&E12)
03800 COLLECT <W CONS '((INIT ABSENT))> ;
03900 ?!SVARS{NIL} ← FOR NEW W IN '(?&S1 ?&S2 ?&S3 ?&S4 ?&S5 ?&S6 ?&S7 ?&S8 ?&S9 ?&S10 ?&S11 ?&S12)
04000 COLLECT <W CONS '((INIT ABSENT))> ;
04100 ?!GVARS{NIL} ← FOR NEW W IN '(?&G1 ?&G2 ?&G3 ?&G4 ?&G5 ?&G6 ?&G7 ?&G8 ?&G9 ?&G10 ?&G11 ?&G12)
04200 COLLECT <W CONS '((INIT ABSENT))> ;
04300 FOR NEW X IN '((TEM_IN 10) (TEM_OUT 100) (TEM_ATOM 20) (TEM_ATOMS 20)
04400 (TEM_REC 110) (TEM_DEC 110) (TEM_LOOP 90) (TEM_IGNORE 80)
04500 (TEM_REPEND 100) (TEM_INDOT 5) (TEM_OUTDOT 100)
04600 (TEM_IF 00)(STRM_CALL 30)(TEM_CALL 40)(TEM_EVAL 50)(TEM_COLON2 50)
04700 (TEM_DO 60)(TEM_COLON 70)(TEM_COLON1 80)(TEM_OPT 65)(TEM_OPTEND 100))
04800 DO (CAR X).RANK{NIL} ← CADR X ;
04900 ?!XEXPRS{NIL} ← NIL ; NOUUO(T) ; RETURN('TABLES) ;
05000 END ;
05100
05200 EXPR PROG1(X,Y) ; X ;
00100 LET PEXPR(P, POSTS) =
00200 { {ALT
00300 <PATOM>
00400 | ?( ?)
00500 | ?( <PEXPRLIST> {OPT ?. <PEXPR>} [MATCHING( '?) )]
00600 | ?[ OPT <PEXPRLIST> [MATCHING( '?] )]
00700 | ?[ <PEXPR> <PEXPRLIST> {OPT <PAUXLIST>} [MATCHING( '?] )]
00800 | ?⊂ <PEXPRLIST> [MATCHING( '?⊃ )]
00900 | ?{ IF <EXPR> ?}
01000 | ?{ DO <EXPR> ?}
01100 | ?{ <EXPR> [MATCHING( '?} )]
01200 | ?< [IDENTIFIER][MATCHING( '?> )] {OPT <PEXPR>}
01300 | ?/ [IDENTIFIER] <PEXPR>
01400 | <COLON>
01500 | ?$ {OPT ?$} [IDENTIFIER]
01600 | ?∞ ?< <PEXPR> ?>
01700 | ?∞ <PEXPR>
01800 | ?` {REP 0 M * { {ALT <COLON>
01900 | <PATOM>
02000 | [IF NEXT('?') THEN FAILURE() ELSE CAR(TOKEN())]
02100 } } } ?'
02200 }
02300 {REP 0 M * {
02400 {REP 0 M * {?& <PAUX>} }
02500 {ALT ?@ {OPT ?@} <PATOM>
02600 | ?* {OPT ?*} }
02700 } } }
02800 MEAN BEGIN NEW M ;
02900 M ← CASE P[1] OF
03000 BEGIN
03100 <'ATOM, P[2]> ;
03200 <'ATOM, NIL> ;
03300 <'ROUND, P[3], IF P[4] & P[4] ≠ '(ATOM NIL) THEN <P[4,2]>> ;
03400 <'OPT, P[4]> ;
03500 <'SQUARE, P[3],
03600 IF LENGTH(P[4])=1 THEN P[4,1] ELSE <'HORSESHOE,P[4]>,
03700 IF P[5] THEN P[5,1]> ;
03800 <'HORSESHOE, P[3]> ;
03900 <'CURLIF, P[3]> ;
04000 <'CURLDO, P[3]> ;
04100 <'CURLY, P[3]> ;
04200 <'ANGLE, P[3], IF P[5] THEN P[5,1] ELSE 'VOID> ;
04300 <'SLASH, P[3], P[4]> ;
04400 P[2] ;
04500 <'CURLY, IF P[3] THEN <'STRIP, P[4]> ELSE P[4]> ;
04600 <'REP, P[4]> ;
04700 <'REP, P[3]> ;
04800 <'HORSESHOE, MAPCAR('CADAR, P[3])> ;
04900 END ;
05000 FOR POST IN POSTS DO
05100 BEGIN
05200 M ← <'SQUARE,
05300 <'ATOM, CASE POST[2,1] OF BEGIN POST[2,4]; '?* END>,
05400 M,
05500 MAPCAR('CADR, POST[1]) > ;
05600 IF POST[2,3] THEN M ← <'STRIP, M> ;
05700 END ;
05800 RETURN M ;
05900 END ;
00100 LET COLON(C) =
00200 { {ALT ?: {OPT ?:} [IDENTIFIER]
00300 | ?. ?. {OPT ?.}
00400 } }
00500 MEAN CASE C[1] OF
00600 BEGIN
00700 <'COLON, C[4], C[3]> ;
00800 <'COLON, NIL, C[4]> ;
00900 END ;
01000
01100
01200 LET PAUX(VAR, *, *, PX) =
01300 { [IDENTIFIER]
01400 ?:
01500 ?=
01600 <PEXPR>
01700 }
01800 MEAN <VAR, PX> ;
01900
02000
02100 LET PAUXLIST(*, *, L) =
02200 { ?&
02300 ?&
02400 {REP 0 M * {<PAUX>}}
02500 }
02600 MEAN MAPCAR('CAR, L) ;
02700
02800
02900 LET PEXPRLIST(L) =
03000 { {REP 0 M * {<PEXPR>} }
03100 }
03200 MEAN MAPCAR('CAR, L) ;
03300
03400
03500 LET PATOM(A) =
03600 { {ALT [IDENTIFIER]
03700 | [NUMBER]
03800 | [STRING]
03900 | ?α [TOKEN]
04000 }
04100 }
04200 MEAN CASE A[1] OF
04300 BEGIN
04400 A[2] ;
04500 A[2] ;
04600 A[2] ;
04700 A[3,1] ;
04800 END ;
04900
05000 EXPR MATCHING(CHR) ;
05100 IF NEXT(CHR) THEN TOKEN()
05200 ELSE PRINTSTR("Missing " CAT CHR) ;
00100 EXPR DEC(PX) ; DEC2(PX, NIL) ;
00200
00300 EXPR DEC2(PX, REST) ;
00400 IF CAR PX EQ 'ATOM THEN <<'TEM_ATOM, PX[2]>>
00500 ELSE IF CAR PX EQ 'ROUND THEN
00600 '((TEM_IN)) @
00700 ( FOR NEW Y ON PX[2] COLLECT DEC2(CAR Y, CDR Y) ) @
00800 IF PX[3] THEN '((TEM_INDOT))@DEC(PX[3,1])@'((TEM_OUTDOT)) ELSE '((TEM_OUT))
00900 ELSE IF CAR PX EQ 'SQUARE THEN
01000 <<'PCALL,REC(PX[2]),REC(PX[3]),FOR NEW Y IN PX[4] COLLECT<<Y[1], REC(Y[2])>> >>
01100 ELSE IF CAR PX EQ 'OPT THEN TOPT(PX[2], 'DEC)
01200 ELSE IF CAR PX EQ 'HORSESHOE THEN
01300 ( FOR NEW Y ON PX[2] COLLECT DEC2(CAR Y, CDR Y) )
01400 ELSE IF CAR PX EQ 'CURLIF THEN <<'TEM_IF, PX[2]>>
01500 ELSE IF CAR PX EQ 'CURLDO THEN <<'TEM_DO, PX[2]>>
01600 ELSE IF CAR PX EQ 'CURLY THEN <<'TEM_EVAL, PX[2]>>
01700 ELSE IF CAR PX EQ 'COLON THEN <COLONVAR(PX[2], 0, PX[3])>
01800 ELSE IF CAR PX EQ 'REP THEN <<'TEM_REP>>@DEC(PX[2])@<<'TEM_REPEND>>
01900 ELSE IF CAR PX EQ 'ANGLE THEN
02000 <<'TEM_LOOP, '?&VAL>> @
02100 <<'STRM_CALL, PX[2], '?&VAL>>@DEC2(PX[3],REST)
02200 ELSE IF CAR PX EQ 'SLASH THEN
02300 <<'TEM_INCHRS, PX[2]>> @ DEC(PX[3]) @ <<'TEM_OUTCHRS, PX[2]>>
02400 ELSE IF CAR PX EQ 'STRIP THEN <<'STRIP, REC(PX[2])>>
02500 ELSE PRINTSTR("IMPOSSIBLE DEC: " & PX) ;
02600
02700 EXPR REC(PX : INV) ;
02800 IF ATOM PX THEN PX
02900 ELSE IF CAR PX EQ 'ATOM THEN
03000 IF ¬PX[2] ∨ NUMBERP(PX[2]) THEN PX[2] ELSE <'QUOTE, PX[2]>
03100 ELSE IF CAR PX EQ 'ROUND THEN
03200 (IF PX[3] THEN 'PLISTDOT ELSE 'PLIST) CONS MAPCAR('REC,PX[2]@PX[3])
03300 ELSE IF CAR PX EQ 'SQUARE THEN <'PCALL, REC(PX[2]), REC(PX[3]),
03400 FOR NEW Y IN PX[4] COLLECT <<Y[1], REC(Y[2])>> >
03500 ELSE IF CAR PX EQ 'OPT THEN TOPT(PX[2], 'REC)
03600 ELSE IF CAR PX EQ 'HORSESHOE THEN
03700 IF LENGTH(PX[2])=1 THEN REC(PX[2,1])
03800 ELSE 'PSTREAM CONS MAPCAR('REC,PX[2])
03900 ELSE IF CAR PX EQ 'CURLIF THEN
04000 <'COND, <PX[2], 'VOID>, '(T (FAIL))>
04100 ELSE IF CAR PX EQ 'CURLDO THEN <'PROG2, PX[2], 'VOID>
04200 ELSE IF CAR PX EQ 'CURLY THEN PX[2]
04300 ELSE IF CAR PX EQ 'COLON THEN COLONVAR(PX[2], 1, PX[3])
04400 ELSE IF CAR PX EQ 'REP THEN PRINTSTR("REC ∞ Unimplemented")
04500 ELSE IF CAR PX EQ 'ANGLE THEN PRINTSTR("<...> unimplemented in REC")
04600 ELSE IF CAR PX EQ 'SLASH THEN
04700 <'PACK_CHARS, PX[2], REC(PX[3])>
04800 ELSE IF CAR PX EQ 'STRIP THEN <'STRIP, REC(PX[2])>
04900 ELSE PRINTSTR("Impossible REC: " & PX) ;
00100 EXPR COLONVAR(V, WHERE, DOUBLE) ;
00200 BEGIN % WHERE: 0=DEC, 1=REC %
00300 NEW K, NUMB ;
00400 IF V OR WHERE EQ 1 THEN
00500 ?!VARLIST ← FOR NEW R IN ?!VARLIST COLLECT <
00600 IF V NEQ CAR R THEN R
00700 ELSE BEGIN %R=(VARNAME, ::, VARNUMBER, 1-3-5-7(see below) )%
00800 IF DOUBLE AND WHERE EQ 0 AND ¬R[2] THEN R[2]←DOUBLE ;
00900 IF ¬V THEN R[1] ← '?&DONT_MATCH_ME ;
01000 IF ?!OPT THEN ?!OPTVARS ← <'TEM_RESTORE, NUMB, NIL> CONS ?!OPTVARS ;
01100 K ← CASE R[4]+WHERE OF
01200 BEGIN
01300 %1: Has been assigned in DEC%
01400 'TEM_COLON2 ; 'COLON2 ;
01500 %3: Has been in DEC OPT%
01600 (IF ¬?!OPT THEN R[4]←1) PROG2 'TEM_COLON ;
01700 (IF ¬?!OPT THEN R[4]←5) PROG2 'COLON ;
01800 %5: Gensym (out of OPT)%
01900 PRINTSTR("IMPOSSIBLE: GENSYM IN DEC!") ;
02000 'COLON2 ;
02100 %7: Gensym only in OPT%
02200 PRINTSTR("IMPOSSIBLE: GENSYM IN DEC!") ;
02300 (IF ¬?!OPT THEN R[4]←5) PROG2 'COLON ;
02400 END ;
02500 NUMB ← R[3] ;
02600 RETURN R ;
02700 END > ;
02800 IF ¬NUMB THEN
02900 BEGIN
03000 K ← IF WHERE=0 THEN 'TEM_COLON1 ELSE 'COLON1 ;
03100 ?!VARLIST ← ?!VARLIST @ <<V,
03200 IF DOUBLE THEN
03300 IF WHERE=0 THEN T ELSE PRINTSTR("::GENSYM!"),
03400 NUMB ← LENGTH(?!VARLIST)+1,
03500 4*WHERE + (IF ?!OPT THEN 3 ELSE 1) >> ;
03600 END ;
03700 K ← <K, NUMB> ;
03800 RETURN IF ¬DOUBLE THEN K ELSE IF WHERE=0 THEN <'TEM_LOOP,K> ELSE <'STRIP,K> ;
03900 END ;
04000
04100 EXPR NUMBVARS(SIDE) ;
04200 IF ATOM SIDE THEN DOLLARVAR(SIDE)
04300 ELSE IF CAR SIDE EQ 'QUOTE THEN SIDE
04400 ELSE IF CAR SIDE MEMQ '(TEM_COLON1 TEM_COLON2 TEM_COLON COLON1 COLON2 COLON) THEN
04500 BEGIN NEW V ; V ← ?!VARLIST[SIDE[2]] ;
04600 RETURN IF V[1] ∨ V[4] GREATERP 4 THEN <SIDE[1], RULEVAR(V)> ELSE '(TEM_IGNORE) ;
04700 END
04800 ELSE MAPCAR('NUMBVARS, SIDE) ;
00100 EXPR DOLLARVAR(V) ; IF ¬V THEN NIL ELSE
00200 BEGIN
00300 NEW K ;
00400 K ← ASSOC(V, ?!VARLIST) ;
00500 RETURN
00600 IF ¬K THEN V
00700 ELSE <'COLON, RULEVAR(K)> ;
00800 END ;
00900
01000 EXPR RULEVAR(R) ;
01100 IF R[4] GREATERP 4 THEN ?!GVARS[R[3]]
01200 ELSE IF R[2] THEN ?!SVARS[R[3]]
01300 ELSE ?!EVARS[R[3]] ;
01400
01500 EXPR RANK(X) ;
01600 IF CAAR X EQ 'TEM_RESTORE THEN RANK(CDR X)
01700 ELSE IF CAAR X EQ 'TEM_ALT THEN 0
01800 ELSE (CAAR X).RANK ;
01900
02000 EXPR TOPT(E, WHERE) ;
02100 BEGIN NEW ?!OPT, ?!OPTVARS, Y ;
02200 ?!OPT ← T ;
02300 Y ← IF WHERE EQ 'DEC THEN DEC(<'HORSESHOE,E>) ELSE REC(<'HORSESHOE,E>) ;
02400 RETURN IF WHERE EQ 'DEC THEN
02500 <<'TEM_OPT>> @ ?!OPTVARS @ Y @ <<'TEM_OPTEND>>
02600 ELSE <'OPT, Y> ;
02700 END ;
00100 EXPR MERGERULES(EXT, ORIG) ;
00200 IF ¬EXT THEN ORIG
00300 ELSE IF ¬ORIG THEN EXT
00400 ELSE <'LAMBDA, '?&ARGS, <'PROG,
00500 IF LENGTH(EXT[3,2]) GREATERP LENGTH(ORIG[3,2]) THEN EXT[3,2]
00600 ELSE ORIG[3,2]>
00700 @ MERGEDECS(CDDR(EXT[3]), CDDR(ORIG[3])) > ;
00800
00900 EXPR MERGEDECS(EXT, ORIG) ;
01000 IF CAAR ORIG EQ 'TEM_ALT THEN
01100 BEGIN
01200 NEW FACD, N ;
01300 N ← FOR NEW M IN CDAR ORIG COLLECT
01400 IF FACD THEN <M>
01500 ELSE IF CAAR(N←MERGEDECS(EXT,M)) NEQ 'TEM_ALT THEN FACD ← <N>
01600 ELSE IF M=N[2] THEN <M>
01700 ELSE FACD ← CDAR N ;
01800 RETURN <IF FACD THEN 'TEM_ALT CONS N ELSE (CAR ORIG) @ <EXT>> ;
01900 END
02000 ELSE IF CAR EXT = CAR ORIG THEN
02100 IF CAAR ORIG EQ 'TEM_REC THEN
02200 IF ?!REPLACE THEN EXT
02300 ELSE CAR ORIG CONS MERGERECS(CDR EXT, CDR ORIG)
02400 ELSE CAR ORIG CONS MERGEDECS(CDR EXT, CDR ORIG)
02500 ELSE IF CAAR EXT EQ 'TEM_ATOM ∧
02600 (CAAR ORIG EQ 'TEM_ATOM ∨ CAAR ORIG EQ 'TEM_ATOMS) THEN
02700 <'TEM_ATOMS CONS FACATOMS(CADAR EXT CONS CDR EXT,
02800 IF CAAR ORIG EQ 'TEM_ATOM THEN <CADAR ORIG CONS CDR ORIG>
02900 ELSE CDAR ORIG)>
03000 ELSE IF RANK(EXT) GREATERP RANK(ORIG) THEN
03100 <<'TEM_ALT, ORIG, EXT>>
03200 ELSE <<'TEM_ALT, EXT, ORIG>> ;
03300
03400 EXPR FACATOMS(A, AA) ;
03500 IF ¬AA THEN <A>
03600 ELSE IF CAR A EQ CAAR AA THEN
03700 (CAR A CONS MERGEDECS(CDR A,CDAR AA)) CONS CDR AA
03800 ELSE CAR AA CONS FACATOMS(A, CDR AA) ;
03900
04000 EXPR MERGERECS(EXT, ORIG) ;
04100 IF EXT = ORIG THEN ORIG
04200 ELSE IF CDR EXT = CDR ORIG THEN
04300 (IF CAAR ORIG EQ 'CHOOSE THEN
04400 IF CAR EXT ε CDAR ORIG THEN CAR ORIG
04500 ELSE <'CHOOSE,CAR EXT> @ CDAR ORIG
04600 ELSE <'CHOOSE, CAR EXT, CAR ORIG>)
04700 CONS CDR(ORIG)
04800 ELSE IF CAAR ORIG EQ 'RETURN ∧ CAADR ORIG EQ 'CHOOSE THEN
04900 <<'RETURN, <'CHOOSE, 'PROG CONS NIL CONS EXT> @ CDADR ORIG>>
05000 ELSE <<'RETURN, <'CHOOSE, 'PROG CONS NIL CONS EXT, 'PROG CONS NIL CONS ORIG>>> ;
05100
05200 _EOF_